home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / Package / Stash.pm < prev   
Encoding:
Perl POD Document  |  2010-06-15  |  12.9 KB  |  446 lines
  1. package Package::Stash;
  2. BEGIN {
  3.   $Package::Stash::VERSION = '0.05';
  4. }
  5. use strict;
  6. use warnings;
  7. # ABSTRACT: routines for manipulating stashes
  8.  
  9. use Carp qw(confess);
  10. use Scalar::Util qw(reftype);
  11.  
  12.  
  13. sub new {
  14.     my $class = shift;
  15.     my ($namespace) = @_;
  16.     return bless { 'package' => $namespace }, $class;
  17. }
  18.  
  19.  
  20. sub name {
  21.     return $_[0]->{package};
  22. }
  23.  
  24.  
  25. sub namespace {
  26.     # NOTE:
  27.     # because of issues with the Perl API
  28.     # to the typeglob in some versions, we
  29.     # need to just always grab a new
  30.     # reference to the hash here. Ideally
  31.     # we could just store a ref and it would
  32.     # Just Work, but oh well :\
  33.     no strict 'refs';
  34.     return \%{$_[0]->name . '::'};
  35. }
  36.  
  37. {
  38.     my %SIGIL_MAP = (
  39.         '$' => 'SCALAR',
  40.         '@' => 'ARRAY',
  41.         '%' => 'HASH',
  42.         '&' => 'CODE',
  43.         ''  => 'IO',
  44.     );
  45.  
  46.     sub _deconstruct_variable_name {
  47.         my ($self, $variable) = @_;
  48.  
  49.         (defined $variable && length $variable)
  50.             || confess "You must pass a variable name";
  51.  
  52.         my $sigil = substr($variable, 0, 1, '');
  53.  
  54.         if (exists $SIGIL_MAP{$sigil}) {
  55.             return ($variable, $sigil, $SIGIL_MAP{$sigil});
  56.         }
  57.         else {
  58.             return ("${sigil}${variable}", '', $SIGIL_MAP{''});
  59.         }
  60.     }
  61. }
  62.  
  63.  
  64. sub _valid_for_type {
  65.     my $self = shift;
  66.     my ($value, $type) = @_;
  67.     if ($type eq 'HASH' || $type eq 'ARRAY'
  68.      || $type eq 'IO'   || $type eq 'CODE') {
  69.         return reftype($value) eq $type;
  70.     }
  71.     else {
  72.         my $ref = reftype($value);
  73.         return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE';
  74.     }
  75. }
  76.  
  77. sub add_package_symbol {
  78.     my ($self, $variable, $initial_value, %opts) = @_;
  79.  
  80.     my ($name, $sigil, $type) = ref $variable eq 'HASH'
  81.         ? @{$variable}{qw[name sigil type]}
  82.         : $self->_deconstruct_variable_name($variable);
  83.  
  84.     my $pkg = $self->name;
  85.  
  86.     if (@_ > 2) {
  87.         $self->_valid_for_type($initial_value, $type)
  88.             || confess "$initial_value is not of type $type";
  89.  
  90.         # cheap fail-fast check for PERLDBf_SUBLINE and '&'
  91.         if ($^P and $^P & 0x10 && $sigil eq '&') {
  92.             my $filename = $opts{filename};
  93.             my $first_line_num = $opts{first_line_num};
  94.  
  95.             (undef, $filename, $first_line_num) = caller
  96.                 if not defined $filename;
  97.  
  98.             my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
  99.  
  100.             # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
  101.             $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
  102.         }
  103.     }
  104.  
  105.     no strict 'refs';
  106.     no warnings 'redefine', 'misc', 'prototype';
  107.     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
  108. }
  109.  
  110.  
  111. sub remove_package_glob {
  112.     my ($self, $name) = @_;
  113.     no strict 'refs';
  114.     delete ${$self->name . '::'}{$name};
  115. }
  116.  
  117. # ... these functions deal with stuff on the namespace level
  118.  
  119.  
  120. sub has_package_symbol {
  121.     my ($self, $variable) = @_;
  122.  
  123.     my ($name, $sigil, $type) = ref $variable eq 'HASH'
  124.         ? @{$variable}{qw[name sigil type]}
  125.         : $self->_deconstruct_variable_name($variable);
  126.  
  127.     my $namespace = $self->namespace;
  128.  
  129.     return unless exists $namespace->{$name};
  130.  
  131.     my $entry_ref = \$namespace->{$name};
  132.     if (reftype($entry_ref) eq 'GLOB') {
  133.         if ( $type eq 'SCALAR' ) {
  134.             return defined ${ *{$entry_ref}{SCALAR} };
  135.         }
  136.         else {
  137.             return defined *{$entry_ref}{$type};
  138.         }
  139.     }
  140.     else {
  141.         # a symbol table entry can be -1 (stub), string (stub with prototype),
  142.         # or reference (constant)
  143.         return $type eq 'CODE';
  144.     }
  145. }
  146.  
  147.  
  148. sub get_package_symbol {
  149.     my ($self, $variable, %opts) = @_;
  150.  
  151.     my ($name, $sigil, $type) = ref $variable eq 'HASH'
  152.         ? @{$variable}{qw[name sigil type]}
  153.         : $self->_deconstruct_variable_name($variable);
  154.  
  155.     my $namespace = $self->namespace;
  156.  
  157.     if (!exists $namespace->{$name}) {
  158.         # assigning to the result of this function like
  159.         #   @{$stash->get_package_symbol('@ISA')} = @new_ISA
  160.         # makes the result not visible until the variable is explicitly
  161.         # accessed... in the case of @ISA, this might never happen
  162.         # for instance, assigning like that and then calling $obj->isa
  163.         # will fail. see t/005-isa.t
  164.         if ($opts{vivify} && $type eq 'ARRAY' && $name ne 'ISA') {
  165.             $self->add_package_symbol($variable, []);
  166.         }
  167.         elsif ($opts{vivify} && $type eq 'HASH') {
  168.             $self->add_package_symbol($variable, {});
  169.         }
  170.         else {
  171.             # FIXME
  172.             $self->add_package_symbol($variable)
  173.         }
  174.     }
  175.  
  176.     my $entry_ref = \$namespace->{$name};
  177.  
  178.     if (ref($entry_ref) eq 'GLOB') {
  179.         return *{$entry_ref}{$type};
  180.     }
  181.     else {
  182.         if ($type eq 'CODE') {
  183.             no strict 'refs';
  184.             return \&{ $self->name . '::' . $name };
  185.         }
  186.         else {
  187.             return undef;
  188.         }
  189.     }
  190. }
  191.  
  192.  
  193. sub get_or_add_package_symbol {
  194.     my $self = shift;
  195.     $self->get_package_symbol(@_, vivify => 1);
  196. }
  197.  
  198.  
  199. sub remove_package_symbol {
  200.     my ($self, $variable) = @_;
  201.  
  202.     my ($name, $sigil, $type) = ref $variable eq 'HASH'
  203.         ? @{$variable}{qw[name sigil type]}
  204.         : $self->_deconstruct_variable_name($variable);
  205.  
  206.     # FIXME:
  207.     # no doubt this is grossly inefficient and
  208.     # could be done much easier and faster in XS
  209.  
  210.     my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
  211.         { sigil => '$', type => 'SCALAR', name => $name },
  212.         { sigil => '@', type => 'ARRAY',  name => $name },
  213.         { sigil => '%', type => 'HASH',   name => $name },
  214.         { sigil => '&', type => 'CODE',   name => $name },
  215.         { sigil => '',  type => 'IO',     name => $name },
  216.     );
  217.  
  218.     my ($scalar, $array, $hash, $code, $io);
  219.     if ($type eq 'SCALAR') {
  220.         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
  221.         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
  222.         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
  223.         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
  224.     }
  225.     elsif ($type eq 'ARRAY') {
  226.         $scalar = $self->get_package_symbol($scalar_desc);
  227.         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
  228.         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
  229.         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
  230.     }
  231.     elsif ($type eq 'HASH') {
  232.         $scalar = $self->get_package_symbol($scalar_desc);
  233.         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
  234.         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
  235.         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
  236.     }
  237.     elsif ($type eq 'CODE') {
  238.         $scalar = $self->get_package_symbol($scalar_desc);
  239.         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
  240.         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
  241.         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
  242.     }
  243.     elsif ($type eq 'IO') {
  244.         $scalar = $self->get_package_symbol($scalar_desc);
  245.         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
  246.         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
  247.         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
  248.     }
  249.     else {
  250.         confess "This should never ever ever happen";
  251.     }
  252.  
  253.     $self->remove_package_glob($name);
  254.  
  255.     $self->add_package_symbol($scalar_desc => $scalar);
  256.     $self->add_package_symbol($array_desc  => $array)  if defined $array;
  257.     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
  258.     $self->add_package_symbol($code_desc   => $code)   if defined $code;
  259.     $self->add_package_symbol($io_desc     => $io)     if defined $io;
  260. }
  261.  
  262.  
  263. sub list_all_package_symbols {
  264.     my ($self, $type_filter) = @_;
  265.  
  266.     my $namespace = $self->namespace;
  267.     return keys %{$namespace} unless defined $type_filter;
  268.  
  269.     # NOTE:
  270.     # or we can filter based on
  271.     # type (SCALAR|ARRAY|HASH|CODE)
  272.     if ($type_filter eq 'CODE') {
  273.         return grep {
  274.             (ref($namespace->{$_})
  275.                 ? (ref($namespace->{$_}) eq 'SCALAR')
  276.                 : (ref(\$namespace->{$_}) eq 'GLOB'
  277.                    && defined(*{$namespace->{$_}}{CODE})));
  278.         } keys %{$namespace};
  279.     } else {
  280.         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
  281.     }
  282. }
  283.  
  284.  
  285. 1;
  286.  
  287. __END__
  288. =pod
  289.  
  290. =head1 NAME
  291.  
  292. Package::Stash - routines for manipulating stashes
  293.  
  294. =head1 VERSION
  295.  
  296. version 0.05
  297.  
  298. =head1 SYNOPSIS
  299.  
  300.   my $stash = Package::Stash->new('Foo');
  301.   $stash->add_package_symbol('%foo', {bar => 1});
  302.   # $Foo::foo{bar} == 1
  303.   $stash->has_package_symbol('$foo') # false
  304.   my $namespace = $stash->namespace;
  305.   *{ $namespace->{foo} }{HASH} # {bar => 1}
  306.  
  307. =head1 DESCRIPTION
  308.  
  309. Manipulating stashes (Perl's symbol tables) is occasionally necessary, but
  310. incredibly messy, and easy to get wrong. This module hides all of that behind a
  311. simple API.
  312.  
  313. NOTE: Most methods in this class require a variable specification that includes
  314. a sigil. If this sigil is absent, it is assumed to represent the IO slot.
  315.  
  316. =head1 METHODS
  317.  
  318. =head2 new $package_name
  319.  
  320. Creates a new C<Package::Stash> object, for the package given as the only
  321. argument.
  322.  
  323. =head2 name
  324.  
  325. Returns the name of the package that this object represents.
  326.  
  327. =head2 namespace
  328.  
  329. Returns the raw stash itself.
  330.  
  331. =head2 add_package_symbol $variable $value %opts
  332.  
  333. Adds a new package symbol, for the symbol given as C<$variable>, and optionally
  334. gives it an initial value of C<$value>. C<$variable> should be the name of
  335. variable including the sigil, so
  336.  
  337.   Package::Stash->new('Foo')->add_package_symbol('%foo')
  338.  
  339. will create C<%Foo::foo>.
  340.  
  341. Valid options (all optional) are C<filename>, C<first_line_num>, and
  342. C<last_line_num>.
  343.  
  344. C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can
  345. be used to indicate where the symbol should be regarded as having been defined.
  346. Currently these values are only used if the symbol is a subroutine ('C<&>'
  347. sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub>
  348. hash is updated to record the values of C<filename>, C<first_line_num>, and
  349. C<last_line_num> for the subroutine. If these are not passed, their values are
  350. inferred (as much as possible) from C<caller> information.
  351.  
  352. This is especially useful for debuggers and profilers, which use C<%DB::sub> to
  353. determine where the source code for a subroutine can be found.  See
  354. L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more
  355. information about C<%DB::sub>.
  356.  
  357. =head2 remove_package_glob $name
  358.  
  359. Removes all package variables with the given name, regardless of sigil.
  360.  
  361. =head2 has_package_symbol $variable
  362.  
  363. Returns whether or not the given package variable (including sigil) exists.
  364.  
  365. =head2 get_package_symbol $variable
  366.  
  367. Returns the value of the given package variable (including sigil).
  368.  
  369. =head2 get_or_add_package_symbol $variable
  370.  
  371. Like C<get_package_symbol>, except that it will return an empty hashref or
  372. arrayref if the variable doesn't exist.
  373.  
  374. =head2 remove_package_symbol $variable
  375.  
  376. Removes the package variable described by C<$variable> (which includes the
  377. sigil); other variables with the same name but different sigils will be
  378. untouched.
  379.  
  380. =head2 list_all_package_symbols $type_filter
  381.  
  382. Returns a list of package variable names in the package, without sigils. If a
  383. C<type_filter> is passed, it is used to select package variables of a given
  384. type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
  385. etc).
  386.  
  387. =head1 BUGS
  388.  
  389. No known bugs.
  390.  
  391. Please report any bugs through RT: email
  392. C<bug-package-stash at rt.cpan.org>, or browse to
  393. L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
  394.  
  395. =head1 SEE ALSO
  396.  
  397. =over 4
  398.  
  399. =item * L<Class::MOP::Package>
  400.  
  401. This module is a factoring out of code that used to live here
  402.  
  403. =back
  404.  
  405. =head1 SUPPORT
  406.  
  407. You can find this documentation for this module with the perldoc command.
  408.  
  409.     perldoc Package::Stash
  410.  
  411. You can also look for information at:
  412.  
  413. =over 4
  414.  
  415. =item * AnnoCPAN: Annotated CPAN documentation
  416.  
  417. L<http://annocpan.org/dist/Package-Stash>
  418.  
  419. =item * CPAN Ratings
  420.  
  421. L<http://cpanratings.perl.org/d/Package-Stash>
  422.  
  423. =item * RT: CPAN's request tracker
  424.  
  425. L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
  426.  
  427. =item * Search CPAN
  428.  
  429. L<http://search.cpan.org/dist/Package-Stash>
  430.  
  431. =back
  432.  
  433. =head1 AUTHOR
  434.  
  435.   Jesse Luehrs <doy at tozt dot net>
  436.  
  437. =head1 COPYRIGHT AND LICENSE
  438.  
  439. This software is copyright (c) 2010 by Jesse Luehrs.
  440.  
  441. This is free software; you can redistribute it and/or modify it under
  442. the same terms as the Perl 5 programming language system itself.
  443.  
  444. =cut
  445.  
  446.